home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / unicore / mktables < prev    next >
Encoding:
Text File  |  2009-06-26  |  62.5 KB  |  2,240 lines
  1. ## !!!!!!!!!!!!!!       IF YOU MODIFY THIS FILE       !!!!!!!!!!!!!!!!!!!!!!!!!
  2. ## Any files created or read by this program should be listed in 'mktables.lst'
  3.  
  4. #!/usr/bin/perl -w
  5. require 5.008;    # Needs pack "U". Probably safest to run on 5.8.x
  6. use strict;
  7. use Carp;
  8. use File::Spec;
  9.  
  10. ##
  11. ## mktables -- create the runtime Perl Unicode files (lib/unicore/**/*.pl)
  12. ## from the Unicode database files (lib/unicore/*.txt).
  13. ##
  14.  
  15. ## "Fuzzy" means this section in Unicode TR18:
  16. ##
  17. ##    The recommended names for UCD properties and property values are in
  18. ##    PropertyAliases.txt [Prop] and PropertyValueAliases.txt
  19. ##    [PropValue]. There are both abbreviated names and longer, more
  20. ##    descriptive names. It is strongly recommended that both names be
  21. ##    recognized, and that loose matching of property names be used,
  22. ##    whereby the case distinctions, whitespace, hyphens, and underbar
  23. ##    are ignored.
  24.  
  25. ## Base names already used in lib/gc_sc (for avoiding 8.3 conflicts)
  26. my %BaseNames;
  27.  
  28. ##
  29. ## Process any args.
  30. ##
  31. my $Verbose        = 0;
  32. my $MakeTestScript = 0;
  33. my $AlwaysWrite    = 0;
  34. my $UseDir         = "";
  35. my $FileList       = "$0.lst";
  36. my $MakeList       = 0;
  37.  
  38. while (@ARGV)
  39. {
  40.     my $arg = shift @ARGV;
  41.     if ($arg eq '-v') {
  42.         $Verbose = 1;
  43.     } elsif ($arg eq '-q') {
  44.         $Verbose = 0;
  45.     } elsif ($arg eq '-w') {
  46.         $AlwaysWrite = 1;    # update the files even if they havent changed
  47.         $FileList = "";
  48.     } elsif ($arg eq '-check') {
  49.         my $this = shift @ARGV;
  50.         my $ok = shift @ARGV;
  51.         if ($this ne $ok) {
  52.             print "Skipping as check params are not the same.\n";
  53.             exit(0);
  54.         }
  55.     } elsif ($arg eq '-maketest') {
  56.         $MakeTestScript = 1;
  57.     } elsif ($arg eq '-makelist') {
  58.         $MakeList = 1;        
  59.     } elsif ($arg eq '-C' && defined ($UseDir = shift)) {
  60.     -d $UseDir or die "Unknown directory '$UseDir'";
  61.     } elsif ($arg eq '-L' && defined ($FileList = shift)) {
  62.         -e $FileList or die "Filelist '$FileList' doesn't appear to exist!";
  63.     } else {
  64.         die "usage: $0 [-v|-q|-w|-C dir|-L filelist] [-maketest] [-makelist]\n",
  65.             "  -v          : Verbose Mode\n",
  66.             "  -q          : Quiet Mode\n",
  67.             "  -w          : Write files regardless\n",
  68.             "  -maketest   : Make test script\n",
  69.             "  -makelist   : Rewrite the file list based on current setup\n",
  70.             "  -L filelist : Use this file list, (defaults to $0)\n",
  71.             "  -C dir      : Change to this directory before proceeding\n",
  72.             "  -check A B  : Executes only if A and B are the same\n";   
  73.     }
  74. }
  75.  
  76. if ($FileList) {
  77.     print "Reading file list '$FileList'\n"
  78.         if $Verbose;
  79.     open my $fh,"<",$FileList or die "Failed to read '$FileList':$!";
  80.     my @input;
  81.     my @output;
  82.     for my $list ( \@input, \@output ) {
  83.         while (<$fh>) {
  84.             s/^ \s+ | \s+ $//xg;
  85.             next if /^ \s* (?: \# .* )? $/x;
  86.             last if /^ =+ $/x;
  87.             my ( $file ) = split /\t/, $_;
  88.             push @$list, $file;
  89.         }
  90.         my %dupe;
  91.         @$list = grep !$dupe{ $_ }++, @$list;
  92.     }
  93.     close $fh;
  94.     die "No input or output files in '$FileList'!"
  95.         if !@input or !@output;
  96.     if ( $MakeList ) {
  97.         foreach my $file (@output) {
  98.             unlink $file;
  99.         }
  100.     }            
  101.     if ( $Verbose ) {
  102.         print "Expecting ".scalar( @input )." input files. ",
  103.               "Checking ".scalar( @output )." output files.\n";
  104.     }
  105.     # we set maxtime to be the youngest input file, including $0 itself.
  106.     my $maxtime = -M $0; # do this before the chdir!
  107.     if ($UseDir) {
  108.         chdir $UseDir or die "Failed to chdir to '$UseDir':$!";
  109.     }
  110.     foreach my $in (@input) {
  111.         my $time = -M $in;
  112.         die "Missing input file '$in'" unless defined $time;
  113.         $maxtime = $time if $maxtime < $time;
  114.     }
  115.  
  116.     # now we check to see if any output files are older than maxtime, if
  117.     # they are we need to continue on, otherwise we can presumably bail.
  118.     my $ok = 1;
  119.     foreach my $out (@output) {
  120.         if ( ! -e $out ) {
  121.             print "'$out' is missing.\n"
  122.                 if $Verbose;
  123.             $ok = 0;
  124.             last;
  125.         }
  126.         if ( -M $out > $maxtime ) {
  127.             print "'$out' is too old.\n"
  128.                 if $Verbose;
  129.             $ok = 0;
  130.             last;
  131.         }
  132.     }
  133.     if ($ok) {
  134.         print "Files seem to be ok, not bothering to rebuild.\n";
  135.         exit(0);
  136.     }
  137.     print "Must rebuild tables.\n"
  138.         if $Verbose;
  139. } else {
  140.     if ($Verbose) {
  141.         print "Not checking filelist.\n";
  142.     }
  143.     if ($UseDir) {
  144.         chdir $UseDir or die "Failed to chdir to '$UseDir':$!";
  145.     }
  146. }
  147.  
  148. foreach my $lib ('To', 'lib',
  149.          map {File::Spec->catdir("lib",$_)}
  150.          qw(gc_sc dt bc hst ea jt lb nt ccc)) {
  151.   next if -d $lib;
  152.   mkdir $lib, 0755 or die "mkdir '$lib': $!";
  153. }
  154.  
  155. my $LastUnicodeCodepoint = 0x10FFFF; # As of Unicode 3.1.1.
  156.  
  157. my $HEADER=<<"EOF";
  158. # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!! 
  159. # This file is built by $0 from e.g. UnicodeData.txt.
  160. # Any changes made here will be lost!
  161.  
  162. EOF
  163.  
  164. sub force_unlink {
  165.     my $filename = shift;
  166.     return unless -e $filename;
  167.     return if CORE::unlink($filename);
  168.     # We might need write permission
  169.     chmod 0777, $filename;
  170.     CORE::unlink($filename) or die "Couldn't unlink $filename: $!\n";
  171. }
  172.  
  173. ##
  174. ## Given a filename and a reference to an array of lines,
  175. ## write the lines to the file only if the contents have not changed.
  176. ## Filename can be given as an arrayref of directory names
  177. ##
  178. sub WriteIfChanged($\@)
  179. {
  180.     my $file  = shift;
  181.     my $lines = shift;
  182.  
  183.     $file = File::Spec->catfile(@$file) if ref $file;
  184.  
  185.     my $TextToWrite = join '', @$lines;
  186.     if (open IN, $file) {
  187.         local($/) = undef;
  188.         my $PreviousText = <IN>;
  189.         close IN;
  190.         if ($PreviousText eq $TextToWrite) {
  191.             print "$file unchanged.\n" if $Verbose;
  192.             return unless $AlwaysWrite;
  193.         }
  194.     }
  195.     force_unlink ($file);
  196.     if (not open OUT, ">$file") {
  197.         die "$0: can't open $file for output: $!\n";
  198.     }
  199.     print "$file written.\n" if $Verbose;
  200.  
  201.     print OUT $TextToWrite;
  202.     close OUT;
  203. }
  204.  
  205. ##
  206. ## The main datastructure (a "Table") represents a set of code points that
  207. ## are part of a particular quality (that are part of \pL, \p{InGreek},
  208. ## etc.). They are kept as ranges of code points (starting and ending of
  209. ## each range).
  210. ##
  211. ## For example, a range ASCII LETTERS would be represented as:
  212. ##   [ [ 0x41 => 0x5A, 'UPPER' ],
  213. ##     [ 0x61 => 0x7A, 'LOWER, ] ]
  214. ##
  215. sub RANGE_START() { 0 } ## index into range element
  216. sub RANGE_END()   { 1 } ## index into range element
  217. sub RANGE_NAME()  { 2 } ## index into range element
  218.  
  219. ## Conceptually, these should really be folded into the 'Table' objects
  220. my %TableInfo;
  221. my %TableDesc;
  222. my %FuzzyNames;
  223. my %AliasInfo;
  224. my %CanonicalToOrig;
  225.  
  226. ##
  227. ## Turn something like
  228. ##    OLD-ITALIC
  229. ## into
  230. ##    OldItalic
  231. ##
  232. sub CanonicalName($)
  233. {
  234.     my $orig = shift;
  235.     my $name = lc $orig;
  236.     $name =~ s/(?<![a-z])(\w)/\u$1/g;
  237.     $name =~ s/[-_\s]+//g;
  238.  
  239.     $CanonicalToOrig{$name} = $orig if not $CanonicalToOrig{$name};
  240.     return $name;
  241. }
  242.  
  243.  
  244. ##
  245. ## Store the alias definitions for later use.
  246. ##
  247. my %PropertyAlias;
  248. my %PropValueAlias;
  249.  
  250. my %PA_reverse;
  251. my %PVA_reverse;
  252.  
  253. sub Build_Aliases()
  254. {
  255.     ##
  256.     ## Most of the work with aliases doesn't occur here,
  257.     ## but rather in utf8_heavy.pl, which uses PVA.pl,
  258.  
  259.     # Placate the warnings about used only once. (They are used again, but
  260.     # via a typeglob lookup)
  261.     %utf8::PropertyAlias = ();
  262.     %utf8::PA_reverse = ();
  263.     %utf8::PropValueAlias = ();
  264.     %utf8::PVA_reverse = ();
  265.     %utf8::PVA_abbr_map = ();
  266.  
  267.     open PA, "< PropertyAliases.txt"
  268.     or confess "Can't open PropertyAliases.txt: $!";
  269.     while (<PA>) {
  270.     s/#.*//;
  271.     s/\s+$//;
  272.     next if /^$/;
  273.  
  274.     my ($abbrev, $name) = split /\s*;\s*/;
  275.         next if $abbrev eq "n/a";
  276.     $PropertyAlias{$abbrev} = $name;
  277.         $PA_reverse{$name} = $abbrev;
  278.  
  279.     # The %utf8::... versions use japhy's code originally from utf8_pva.pl
  280.     # However, it's moved here so that we build the tables at runtime.
  281.     tr/ _-//d for $abbrev, $name;
  282.     $utf8::PropertyAlias{lc $abbrev} = $name;
  283.     $utf8::PA_reverse{lc $name} = $abbrev;
  284.     }
  285.     close PA;
  286.  
  287.     open PVA, "< PropValueAliases.txt"
  288.     or confess "Can't open PropValueAliases.txt: $!";
  289.     while (<PVA>) {
  290.     s/#.*//;
  291.     s/\s+$//;
  292.     next if /^$/;
  293.  
  294.     my ($prop, @data) = split /\s*;\s*/;
  295.  
  296.     if ($prop eq 'ccc') {
  297.         $PropValueAlias{$prop}{$data[1]} = [ @data[0,2] ];
  298.         $PVA_reverse{$prop}{$data[2]} = [ @data[0,1] ];
  299.     }
  300.     else {
  301.             next if $data[0] eq "n/a";
  302.         $PropValueAlias{$prop}{$data[0]} = $data[1];
  303.             $PVA_reverse{$prop}{$data[1]} = $data[0];
  304.     }
  305.  
  306.     shift @data if $prop eq 'ccc';
  307.     next if $data[0] eq "n/a";
  308.  
  309.     $data[1] =~ tr/ _-//d;
  310.     $utf8::PropValueAlias{$prop}{lc $data[0]} = $data[1];
  311.     $utf8::PVA_reverse{$prop}{lc $data[1]} = $data[0];
  312.  
  313.     my $abbr_class = ($prop eq 'gc' or $prop eq 'sc') ? 'gc_sc' : $prop;
  314.     $utf8::PVA_abbr_map{$abbr_class}{lc $data[0]} = $data[0];
  315.     }
  316.     close PVA;
  317.  
  318.     # backwards compatibility for L& -> LC
  319.     $utf8::PropValueAlias{gc}{'l&'} = $utf8::PropValueAlias{gc}{lc};
  320.     $utf8::PVA_abbr_map{gc_sc}{'l&'} = $utf8::PVA_abbr_map{gc_sc}{lc};
  321.  
  322. }
  323.  
  324.  
  325. ##
  326. ## Associates a property ("Greek", "Lu", "Assigned",...) with a Table.
  327. ##
  328. ## Called like:
  329. ##       New_Prop(In => 'Greek', $Table, Desc => 'Greek Block', Fuzzy => 1);
  330. ##
  331. ## Normally, these parameters are set when the Table is created (when the
  332. ## Table->New constructor is called), but there are times when it needs to
  333. ## be done after-the-fact...)
  334. ##
  335. sub New_Prop($$$@)
  336. {
  337.     my $Type = shift; ## "Is" or "In";
  338.     my $Name = shift;
  339.     my $Table = shift;
  340.  
  341.     ## remaining args are optional key/val
  342.     my %Args = @_;
  343.  
  344.     my $Fuzzy = delete $Args{Fuzzy};
  345.     my $Desc  = delete $Args{Desc}; # description
  346.  
  347.     $Name = CanonicalName($Name) if $Fuzzy;
  348.  
  349.     ## sanity check a few args
  350.     if (%Args or ($Type ne 'Is' and $Type ne 'In') or not ref $Table) {
  351.         confess "$0: bad args to New_Prop"
  352.     }
  353.  
  354.     if (not $TableInfo{$Type}->{$Name})
  355.     {
  356.         $TableInfo{$Type}->{$Name} = $Table;
  357.         $TableDesc{$Type}->{$Name} = $Desc;
  358.         if ($Fuzzy) {
  359.             $FuzzyNames{$Type}->{$Name} = $Name;
  360.         }
  361.     }
  362. }
  363.  
  364.  
  365. ##
  366. ## Creates a new Table object.
  367. ##
  368. ## Args are key/value pairs:
  369. ##    In => Name         -- Name of "In" property to be associated with
  370. ##    Is => Name         -- Name of "Is" property to be associated with
  371. ##    Fuzzy => Boolean   -- True if name can be accessed "fuzzily"
  372. ##    Desc  => String    -- Description of the property
  373. ##
  374. ## No args are required.
  375. ##
  376. sub Table::New
  377. {
  378.     my $class = shift;
  379.     my %Args = @_;
  380.  
  381.     my $Table = bless [], $class;
  382.  
  383.     my $Fuzzy = delete $Args{Fuzzy};
  384.     my $Desc  = delete $Args{Desc};
  385.  
  386.     for my $Type ('Is', 'In')
  387.     {
  388.         if (my $Name = delete $Args{$Type}) {
  389.             New_Prop($Type => $Name, $Table, Desc => $Desc, Fuzzy => $Fuzzy);
  390.         }
  391.     }
  392.  
  393.     ## shouldn't have any left over
  394.     if (%Args) {
  395.         confess "$0: bad args to Table->New"
  396.     }
  397.  
  398.     return $Table;
  399. }
  400.  
  401.  
  402. ##
  403. ## Returns the maximum code point currently in the table.
  404. ##
  405. sub Table::Max
  406. {
  407.     my $last = $_[0]->[-1];      ## last code point
  408.     confess "oops" unless $last; ## must have code points to have a max
  409.     return $last->[RANGE_END];
  410. }
  411.  
  412. ##
  413. ## Replaces the codepoints in the Table with those in the Table given
  414. ## as an arg. (NOTE: this is not a "deep copy").
  415. ##
  416. sub Table::Replace($$)
  417. {
  418.     my $Table = shift; #self
  419.     my $New   = shift;
  420.  
  421.     @$Table = @$New;
  422. }
  423.  
  424. ##
  425. ## Given a new code point, make the last range of the Table extend to
  426. ## include the new (and all intervening) code points.
  427. ##
  428. ## Takes the time to make sure that the extension is valid.
  429. ##
  430. sub Table::Extend
  431. {
  432.     my $Table = shift; #self
  433.     my $codepoint = shift;
  434.  
  435.     my $PrevMax = $Table->Max;
  436.  
  437.     confess "oops ($codepoint <= $PrevMax)" if $codepoint <= $PrevMax;
  438.  
  439.     $Table->ExtendNoCheck($codepoint);
  440. }
  441.  
  442.  
  443. ##
  444. ## Given a new code point, make the last range of the Table extend to
  445. ## include the new (and all intervening) code points.
  446. ##
  447. ## Does NOT check that the extension is valid.  Assumes that the caller
  448. ## has already made this check.
  449. ##
  450. sub Table::ExtendNoCheck
  451. {
  452.     ## Optmized adding: Assumes $Table and $codepoint as parms
  453.     $_[0]->[-1]->[RANGE_END] = $_[1];
  454. }
  455.  
  456. ##
  457. ## Given a code point range start and end (and optional name), blindly
  458. ## append them to the list of ranges for the Table.
  459. ##
  460. ## NOTE: Code points must be added in strictly ascending numeric order.
  461. ##
  462. sub Table::RawAppendRange
  463. {
  464.     my $Table = shift; #self
  465.     my $start = shift;
  466.     my $end   = shift;
  467.     my $name  = shift;
  468.     $name = "" if not defined $name; ## warning: $name can be "0"
  469.  
  470.     push @$Table, [ $start,    # RANGE_START
  471.                     $end,      # RANGE_END
  472.                     $name   ]; # RANGE_NAME
  473. }
  474.  
  475. ##
  476. ## Given a code point (and optional name), add it to the Table.
  477. ##
  478. ## NOTE: Code points must be added in strictly ascending numeric order.
  479. ##
  480. sub Table::Append
  481. {
  482.     my $Table     = shift; #self
  483.     my $codepoint = shift;
  484.     my $name      = shift;
  485.     $name = "" if not defined $name; ## warning: $name can be "0"
  486.  
  487.     ##
  488.     ## If we've already got a range working, and this code point is the next
  489.     ## one in line, and if the name is the same, just extend the current range.
  490.     ##
  491.     my $last = $Table->[-1];
  492.     if ($last
  493.         and
  494.         $last->[RANGE_END] == $codepoint - 1
  495.         and
  496.         $last->[RANGE_NAME] eq $name)
  497.     {
  498.         $Table->ExtendNoCheck($codepoint);
  499.     }
  500.     else
  501.     {
  502.         $Table->RawAppendRange($codepoint, $codepoint, $name);
  503.     }
  504. }
  505.  
  506. ##
  507. ## Given a code point range starting value and ending value (and name),
  508. ## Add the range to teh Table.
  509. ##
  510. ## NOTE: Code points must be added in strictly ascending numeric order.
  511. ##
  512. sub Table::AppendRange
  513. {
  514.     my $Table = shift; #self
  515.     my $start = shift;
  516.     my $end   = shift;
  517.     my $name  = shift;
  518.     $name = "" if not defined $name; ## warning: $name can be "0"
  519.  
  520.     $Table->Append($start, $name);
  521.     $Table->Extend($end) if $end > $start;
  522. }
  523.  
  524. ##
  525. ## Return a new Table that represents all code points not in the Table.
  526. ##
  527. sub Table::Invert
  528. {
  529.     my $Table = shift; #self
  530.  
  531.     my $New = Table->New();
  532.     my $max = -1;
  533.     for my $range (@$Table)
  534.     {
  535.         my $start = $range->[RANGE_START];
  536.         my $end   = $range->[RANGE_END];
  537.         if ($start-1 >= $max+1) {
  538.             $New->AppendRange($max+1, $start-1, "");
  539.         }
  540.         $max = $end;
  541.     }
  542.     if ($max+1 < $LastUnicodeCodepoint) {
  543.         $New->AppendRange($max+1, $LastUnicodeCodepoint);
  544.     }
  545.     return $New;
  546. }
  547.  
  548. ##
  549. ## Merges any number of other tables with $self, returning the new table.
  550. ## (existing tables are not modified)
  551. ##
  552. ##
  553. ## Args may be Tables, or individual code points (as integers).
  554. ##
  555. ## Can be called as either a constructor or a method.
  556. ##
  557. sub Table::Merge
  558. {
  559.     shift(@_) if not ref $_[0]; ## if called as a constructor, lose the class
  560.     my @Tables = @_;
  561.  
  562.     ## Accumulate all records from all tables
  563.     my @Records;
  564.     for my $Arg (@Tables)
  565.     {
  566.         if (ref $Arg) {
  567.             ## arg is a table -- get its ranges
  568.             push @Records, @$Arg;
  569.         } else {
  570.             ## arg is a codepoint, make a range
  571.             push @Records, [ $Arg, $Arg ]
  572.         }
  573.     }
  574.  
  575.     ## sort by range start, with longer ranges coming first.
  576.     my ($first, @Rest) = sort {
  577.         ($a->[RANGE_START] <=> $b->[RANGE_START])
  578.           or
  579.         ($b->[RANGE_END]   <=> $b->[RANGE_END])
  580.     } @Records;
  581.  
  582.     my $New = Table->New();
  583.  
  584.     ## Ensuring the first range is there makes the subsequent loop easier
  585.     $New->AppendRange($first->[RANGE_START],
  586.                       $first->[RANGE_END]);
  587.  
  588.     ## Fold in records so long as they add new information.
  589.     for my $set (@Rest)
  590.     {
  591.         my $start = $set->[RANGE_START];
  592.         my $end   = $set->[RANGE_END];
  593.         if ($start > $New->Max) {
  594.             $New->AppendRange($start, $end);
  595.         } elsif ($end > $New->Max) {
  596.             $New->ExtendNoCheck($end);
  597.         }
  598.     }
  599.  
  600.     return $New;
  601. }
  602.  
  603. ##
  604. ## Given a filename, write a representation of the Table to a file.
  605. ## May have an optional comment as a 2nd arg.
  606. ## Filename may actually be an arrayref of directories
  607. ##
  608. sub Table::Write
  609. {
  610.     my $Table    = shift; #self
  611.     my $filename = shift;
  612.     my $comment  = shift;
  613.  
  614.     my @OUT = $HEADER;
  615.     if (defined $comment) {
  616.         $comment =~ s/\s+\Z//;
  617.         $comment =~ s/^/# /gm;
  618.         push @OUT, "#\n$comment\n#\n";
  619.     }
  620.     push @OUT, "return <<'END';\n";
  621.  
  622.     for my $set (@$Table)
  623.     {
  624.         my $start = $set->[RANGE_START];
  625.         my $end   = $set->[RANGE_END];
  626.         my $name  = $set->[RANGE_NAME];
  627.  
  628.         if ($start == $end) {
  629.             push @OUT, sprintf "%04X\t\t%s\n", $start, $name;
  630.         } else {
  631.             push @OUT, sprintf "%04X\t%04X\t%s\n", $start, $end, $name;
  632.         }
  633.     }
  634.  
  635.     push @OUT, "END\n";
  636.  
  637.     WriteIfChanged($filename, @OUT);
  638. }
  639.  
  640. ## This used only for making the test script.
  641. ## helper function
  642. sub IsUsable($)
  643. {
  644.     my $code = shift;
  645.     return 0 if $code <= 0x0000;                       ## don't use null
  646.     return 0 if $code >= $LastUnicodeCodepoint;        ## keep in range
  647.     return 0 if ($code >= 0xD800 and $code <= 0xDFFF); ## no surrogates
  648.     return 0 if ($code >= 0xFDD0 and $code <= 0xFDEF); ## utf8.c says no good
  649.     return 0 if (($code & 0xFFFF) == 0xFFFE);          ## utf8.c says no good
  650.     return 0 if (($code & 0xFFFF) == 0xFFFF);          ## utf8.c says no good
  651.     return 1;
  652. }
  653.  
  654. ## Return a code point that's part of the table.
  655. ## Returns nothing if the table is empty (or covers only surrogates).
  656. ## This used only for making the test script.
  657. sub Table::ValidCode
  658. {
  659.     my $Table = shift; #self
  660.     for my $set (@$Table) {
  661.         return $set->[RANGE_END] if IsUsable($set->[RANGE_END]);
  662.     }
  663.     return ();
  664. }
  665.  
  666. ## Return a code point that's not part of the table
  667. ## Returns nothing if the table covers all code points.
  668. ## This used only for making the test script.
  669. sub Table::InvalidCode
  670. {
  671.     my $Table = shift; #self
  672.  
  673.     return 0x1234 if not @$Table;
  674.  
  675.     for my $set (@$Table)
  676.     {
  677.         if (IsUsable($set->[RANGE_END] + 1))
  678.         {
  679.             return $set->[RANGE_END] + 1;
  680.         }
  681.  
  682.         if (IsUsable($set->[RANGE_START] - 1))
  683.         {
  684.             return $set->[RANGE_START] - 1;
  685.         }
  686.     }
  687.     return ();
  688. }
  689.  
  690. ###########################################################################
  691. ###########################################################################
  692. ###########################################################################
  693.  
  694.  
  695. ##
  696. ## Called like:
  697. ##     New_Alias(Is => 'All', SameAs => 'Any', Fuzzy => 1);
  698. ##
  699. ## The args must be in that order, although the Fuzzy pair may be omitted.
  700. ##
  701. ## This creates 'IsAll' as an alias for 'IsAny'
  702. ##
  703. sub New_Alias($$$@)
  704. {
  705.     my $Type   = shift; ## "Is" or "In"
  706.     my $Alias  = shift;
  707.     my $SameAs = shift; # expecting "SameAs" -- just ignored
  708.     my $Name   = shift;
  709.  
  710.     ## remaining args are optional key/val
  711.     my %Args = @_;
  712.  
  713.     my $Fuzzy = delete $Args{Fuzzy};
  714.  
  715.     ## sanity check a few args
  716.     if (%Args or ($Type ne 'Is' and $Type ne 'In') or $SameAs ne 'SameAs') {
  717.         confess "$0: bad args to New_Alias"
  718.     }
  719.  
  720.     $Alias = CanonicalName($Alias) if $Fuzzy;
  721.  
  722.     if (not $TableInfo{$Type}->{$Name})
  723.     {
  724.         my $CName = CanonicalName($Name);
  725.         if ($TableInfo{$Type}->{$CName}) {
  726.             confess "$0: Use canonical form '$CName' instead of '$Name' for alias.";
  727.         } else {
  728.             confess "$0: don't have original $Type => $Name to make alias\n";
  729.         }
  730.     }
  731.     if ($TableInfo{$Alias}) {
  732.         confess "$0: already have original $Type => $Alias; can't make alias";
  733.     }
  734.     $AliasInfo{$Type}->{$Name} = $Alias;
  735.     if ($Fuzzy) {
  736.         $FuzzyNames{$Type}->{$Alias} = $Name;
  737.     }
  738.  
  739. }
  740.  
  741.  
  742. ## All assigned code points
  743. my $Assigned = Table->New(Is    => 'Assigned',
  744.                           Desc  => "All assigned code points",
  745.                           Fuzzy => 0);
  746.  
  747. my $Name     = Table->New(); ## all characters, individually by name
  748. my $General  = Table->New(); ## all characters, grouped by category
  749. my %General;
  750. my %Cat;
  751.  
  752. ## Simple Data::Dumper alike. Good enough for our needs. We can't use the real
  753. ## thing as we have to run under miniperl
  754. sub simple_dumper {
  755.     my @lines;
  756.     my $item;
  757.     foreach $item (@_) {
  758.     if (ref $item) {
  759.         if (ref $item eq 'ARRAY') {
  760.         push @lines, "[\n", simple_dumper (@$item), "],\n";
  761.         } elsif (ref $item eq 'HASH') {
  762.         push @lines, "{\n", simple_dumper (%$item), "},\n";
  763.         } else {
  764.         die "Can't cope with $item";
  765.         }
  766.     } else {
  767.         if (defined $item) {
  768.         my $copy = $item;
  769.         $copy =~ s/([\'\\])/\\$1/gs;
  770.         push @lines, "'$copy',\n";
  771.         } else {
  772.         push @lines, "undef,\n";
  773.         }
  774.     }
  775.     }
  776.     @lines;
  777. }
  778.  
  779. ##
  780. ## Process UnicodeData.txt (Categories, etc.)
  781. ##
  782. sub UnicodeData_Txt()
  783. {
  784.     my $Bidi     = Table->New();
  785.     my $Deco     = Table->New();
  786.     my $Comb     = Table->New();
  787.     my $Number   = Table->New();
  788.     my $Mirrored = Table->New();#Is    => 'Mirrored',
  789.                               #Desc  => "Mirrored in bidirectional text",
  790.                               #Fuzzy => 0);
  791.  
  792.     my %DC;
  793.     my %Bidi;
  794.     my %Number;
  795.     $DC{can} = Table->New();
  796.     $DC{com} = Table->New();
  797.  
  798.     ## Initialize Perl-generated categories
  799.     ## (Categories from UnicodeData.txt are auto-initialized in gencat)
  800.     $Cat{Alnum}  =
  801.     Table->New(Is => 'Alnum',  Desc => "[[:Alnum:]]",  Fuzzy => 0);
  802.     $Cat{Alpha}  =
  803.     Table->New(Is => 'Alpha',  Desc => "[[:Alpha:]]",  Fuzzy => 0);
  804.     $Cat{ASCII}  =
  805.     Table->New(Is => 'ASCII',  Desc => "[[:ASCII:]]",  Fuzzy => 0);
  806.     $Cat{Blank}  =
  807.     Table->New(Is => 'Blank',  Desc => "[[:Blank:]]",  Fuzzy => 0);
  808.     $Cat{Cntrl}  =
  809.     Table->New(Is => 'Cntrl',  Desc => "[[:Cntrl:]]",  Fuzzy => 0);
  810.     $Cat{Digit}  =
  811.     Table->New(Is => 'Digit',  Desc => "[[:Digit:]]",  Fuzzy => 0);
  812.     $Cat{Graph}  =
  813.     Table->New(Is => 'Graph',  Desc => "[[:Graph:]]",  Fuzzy => 0);
  814.     $Cat{Lower}  =
  815.     Table->New(Is => 'Lower',  Desc => "[[:Lower:]]",  Fuzzy => 0);
  816.     $Cat{Print}  =
  817.     Table->New(Is => 'Print',  Desc => "[[:Print:]]",  Fuzzy => 0);
  818.     $Cat{Punct}  =
  819.     Table->New(Is => 'Punct',  Desc => "[[:Punct:]]",  Fuzzy => 0);
  820.     $Cat{Space}  =
  821.     Table->New(Is => 'Space',  Desc => "[[:Space:]]",  Fuzzy => 0);
  822.     $Cat{Title}  =
  823.     Table->New(Is => 'Title',  Desc => "[[:Title:]]",  Fuzzy => 0);
  824.     $Cat{Upper}  =
  825.     Table->New(Is => 'Upper',  Desc => "[[:Upper:]]",  Fuzzy => 0);
  826.     $Cat{XDigit} =
  827.     Table->New(Is => 'XDigit', Desc => "[[:XDigit:]]", Fuzzy => 0);
  828.     $Cat{Word}   =
  829.     Table->New(Is => 'Word',   Desc => "[[:Word:]]",   Fuzzy => 0);
  830.     $Cat{SpacePerl} =
  831.     Table->New(Is => 'SpacePerl', Desc => '\s', Fuzzy => 0);
  832.     $Cat{VertSpace} =
  833.     Table->New(Is => 'VertSpace', Desc => '\v', Fuzzy => 0);
  834.     $Cat{HorizSpace} =
  835.     Table->New(Is => 'HorizSpace', Desc => '\h', Fuzzy => 0);
  836.     my %To;
  837.     $To{Upper} = Table->New();
  838.     $To{Lower} = Table->New();
  839.     $To{Title} = Table->New();
  840.     $To{Digit} = Table->New();
  841.  
  842.     sub gencat($$$$)
  843.     {
  844.         my ($name, ## Name ("LATIN CAPITAL LETTER A")
  845.             $cat,  ## Category ("Lu", "Zp", "Nd", etc.)
  846.             $code, ## Code point (as an integer)
  847.             $op) = @_;
  848.  
  849.         my $MajorCat = substr($cat, 0, 1); ## L, M, Z, S, etc
  850.  
  851.         $Assigned->$op($code);
  852.         $Name->$op($code, $name);
  853.         $General->$op($code, $cat);
  854.  
  855.         ## add to the sub category (e.g. "Lu", "Nd", "Cf", ..)
  856.         $Cat{$cat}      ||= Table->New(Is   => $cat,
  857.                                        Desc => "General Category '$cat'",
  858.                                        Fuzzy => 0);
  859.         $Cat{$cat}->$op($code);
  860.  
  861.         ## add to the major category (e.g. "L", "N", "C", ...)
  862.         $Cat{$MajorCat} ||= Table->New(Is => $MajorCat,
  863.                                        Desc => "Major Category '$MajorCat'",
  864.                                        Fuzzy => 0);
  865.         $Cat{$MajorCat}->$op($code);
  866.  
  867.         ($General{$name} ||= Table->New)->$op($code, $name);
  868.  
  869.         # 005F: SPACING UNDERSCORE
  870.         $Cat{Word}->$op($code)  if $cat =~ /^[LMN]|Pc/;
  871.         $Cat{Alnum}->$op($code) if $cat =~ /^[LM]|Nd/;
  872.         $Cat{Alpha}->$op($code) if $cat =~ /^[LM]/;
  873.  
  874.     my $isspace = 
  875.         ($cat =~ /Zs|Zl|Zp/ &&
  876.          $code != 0x200B) # 200B is ZWSP which is for line break control
  877.          # and therefore it is not part of "space" even while it is "Zs".
  878.                                 || $code == 0x0009  # 0009: HORIZONTAL TAB
  879.                                 || $code == 0x000A  # 000A: LINE FEED
  880.                                 || $code == 0x000B  # 000B: VERTICAL TAB
  881.                                 || $code == 0x000C  # 000C: FORM FEED
  882.                                 || $code == 0x000D  # 000D: CARRIAGE RETURN
  883.                                 || $code == 0x0085  # 0085: NEL
  884.  
  885.         ;
  886.  
  887.         $Cat{Space}->$op($code) if $isspace;
  888.  
  889.         $Cat{SpacePerl}->$op($code) if $isspace
  890.                                    && $code != 0x000B; # Backward compat.
  891.  
  892.         $Cat{VertSpace}->$op($code) if grep {$code == $_} 
  893.             ( 0x0A..0x0D,0x85,0x2028,0x2029 );
  894.  
  895.         $Cat{HorizSpace}->$op($code) if grep {$code == $_} (
  896.             0x09,   0x20,   0xa0,   0x1680, 0x180e, 0x2000, 0x2001, 0x2002,
  897.             0x2003, 0x2004, 0x2005, 0x2006, 0x2007, 0x2008, 0x2009, 0x200a,
  898.             0x202f, 0x205f, 0x3000
  899.         ); 
  900.  
  901.         $Cat{Blank}->$op($code) if $isspace
  902.                                 && !($code == 0x000A ||
  903.                      $code == 0x000B ||
  904.                      $code == 0x000C ||
  905.                      $code == 0x000D ||
  906.                      $code == 0x0085 ||
  907.                      $cat =~ /^Z[lp]/);
  908.  
  909.         $Cat{Digit}->$op($code) if $cat eq "Nd";
  910.         $Cat{Upper}->$op($code) if $cat eq "Lu";
  911.         $Cat{Lower}->$op($code) if $cat eq "Ll";
  912.         $Cat{Title}->$op($code) if $cat eq "Lt";
  913.         $Cat{ASCII}->$op($code) if $code <= 0x007F;
  914.         $Cat{Cntrl}->$op($code) if $cat =~ /^C/;
  915.     my $isgraph = !$isspace && $cat !~ /Cc|Cs|Cn/;
  916.         $Cat{Graph}->$op($code) if $isgraph;
  917.         $Cat{Print}->$op($code) if $isgraph || $isspace;
  918.         $Cat{Punct}->$op($code) if $cat =~ /^P/;
  919.  
  920.         $Cat{XDigit}->$op($code) if ($code >= 0x30 && $code <= 0x39)  ## 0..9
  921.                                  || ($code >= 0x41 && $code <= 0x46)  ## A..F
  922.                                  || ($code >= 0x61 && $code <= 0x66); ## a..f
  923.     }
  924.  
  925.     ## open ane read file.....
  926.     if (not open IN, "UnicodeData.txt") {
  927.         die "$0: UnicodeData.txt: $!\n";
  928.     }
  929.  
  930.     ##
  931.     ## For building \p{_CombAbove} and \p{_CanonDCIJ}
  932.     ##
  933.     my %_Above_HexCodes; ## Hexcodes for chars with $comb == 230 ("ABOVE")
  934.  
  935.     my %CodeToDeco;      ## Maps code to decomp. list for chars with first
  936.                          ## decomp. char an "i" or "j" (for \p{_CanonDCIJ})
  937.  
  938.     ## This is filled in as we go....
  939.     my $CombAbove = Table->New(Is   => '_CombAbove',
  940.                                Desc  => '(for internal casefolding use)',
  941.                                Fuzzy => 0);
  942.  
  943.     while (<IN>)
  944.     {
  945.         next unless /^[0-9A-Fa-f]+;/;
  946.         s/\s+$//;
  947.  
  948.         my ($hexcode,   ## code point in hex (e.g. "0041")
  949.             $name,      ## character name (e.g. "LATIN CAPITAL LETTER A")
  950.             $cat,       ## category (e.g. "Lu")
  951.             $comb,      ## Canonical combining class (e.t. "230")
  952.             $bidi,      ## directional category (e.g. "L")
  953.             $deco,      ## decomposition mapping
  954.             $decimal,   ## decimal digit value
  955.             $digit,     ## digit value
  956.             $number,    ## numeric value
  957.             $mirrored,  ## mirrored
  958.             $unicode10, ## name in Unicode 1.0
  959.             $comment,   ## comment field
  960.             $upper,     ## uppercase mapping
  961.             $lower,     ## lowercase mapping
  962.             $title,     ## titlecase mapping
  963.               ) = split(/\s*;\s*/);
  964.  
  965.     # Note that in Unicode 3.2 there will be names like
  966.     # LINE FEED (LF), which probably means that \N{} needs
  967.     # to cope also with LINE FEED and LF.
  968.     $name = $unicode10 if $name eq '<control>' && $unicode10 ne '';
  969.  
  970.         my $code = hex($hexcode);
  971.  
  972.         if ($comb and $comb == 230) {
  973.             $CombAbove->Append($code);
  974.             $_Above_HexCodes{$hexcode} = 1;
  975.         }
  976.  
  977.         ## Used in building \p{_CanonDCIJ}
  978.         if ($deco and $deco =~ m/^006[9A]\b/) {
  979.             $CodeToDeco{$code} = $deco;
  980.         }
  981.  
  982.         ##
  983.         ## There are a few pairs of lines like:
  984.         ##   AC00;<Hangul Syllable, First>;Lo;0;L;;;;;N;;;;;
  985.         ##   D7A3;<Hangul Syllable, Last>;Lo;0;L;;;;;N;;;;;
  986.         ## that define ranges.
  987.         ##
  988.         if ($name =~ /^<(.+), (First|Last)>$/)
  989.         {
  990.             $name = $1;
  991.             gencat($name, $cat, $code, $2 eq 'First' ? 'Append' : 'Extend');
  992.             #New_Prop(In => $name, $General{$name}, Fuzzy => 1);
  993.         }
  994.         else
  995.         {
  996.             ## normal (single-character) lines
  997.             gencat($name, $cat, $code, 'Append');
  998.  
  999.             # No Append() here since since several codes may map into one.
  1000.             $To{Upper}->RawAppendRange($code, $code, $upper) if $upper;
  1001.             $To{Lower}->RawAppendRange($code, $code, $lower) if $lower;
  1002.             $To{Title}->RawAppendRange($code, $code, $title) if $title;
  1003.             $To{Digit}->Append($code, $decimal) if length $decimal;
  1004.  
  1005.             $Bidi->Append($code, $bidi);
  1006.             $Comb->Append($code, $comb) if $comb;
  1007.             $Number->Append($code, $number) if length $number;
  1008.  
  1009.         length($decimal) and ($Number{De} ||= Table->New())->Append($code)
  1010.           or
  1011.         length($digit)   and ($Number{Di} ||= Table->New())->Append($code)
  1012.           or
  1013.         length($number)  and ($Number{Nu} ||= Table->New())->Append($code);
  1014.  
  1015.             $Mirrored->Append($code) if $mirrored eq "Y";
  1016.  
  1017.             $Bidi{$bidi} ||= Table->New();#Is    => "bt/$bidi",
  1018.                                         #Desc  => "Bi-directional category '$bidi'",
  1019.                                         #Fuzzy => 0);
  1020.             $Bidi{$bidi}->Append($code);
  1021.  
  1022.             if ($deco)
  1023.             {
  1024.                 $Deco->Append($code, $deco);
  1025.                 if ($deco =~/^<(\w+)>/)
  1026.                 {
  1027.             my $dshort = $PVA_reverse{dt}{ucfirst lc $1};
  1028.                     $DC{com}->Append($code);
  1029.  
  1030.                     $DC{$dshort} ||= Table->New();
  1031.                     $DC{$dshort}->Append($code);
  1032.                 }
  1033.                 else
  1034.                 {
  1035.                     $DC{can}->Append($code);
  1036.                 }
  1037.             }
  1038.         }
  1039.     }
  1040.     close IN;
  1041.  
  1042.     ##
  1043.     ## Tidy up a few special cases....
  1044.     ##
  1045.  
  1046.     $Cat{Cn} = $Assigned->Invert; ## Cn is everything that doesn't exist
  1047.     New_Prop(Is => 'Cn',
  1048.              $Cat{Cn},
  1049.              Desc => "General Category 'Cn' [not functional in Perl]",
  1050.              Fuzzy => 0);
  1051.  
  1052.     ## Unassigned is the same as 'Cn'
  1053.     New_Alias(Is => 'Unassigned', SameAs => 'Cn', Fuzzy => 0);
  1054.  
  1055.     $Cat{C}->Replace($Cat{C}->Merge($Cat{Cn}));  ## Now merge in Cn into C
  1056.  
  1057.  
  1058.     # LC is Ll, Lu, and Lt.
  1059.     # (used to be L& or L_, but PropValueAliases.txt defines it as LC)
  1060.     New_Prop(Is => 'LC',
  1061.              Table->Merge(@Cat{qw[Ll Lu Lt]}),
  1062.              Desc  => '[\p{Ll}\p{Lu}\p{Lt}]',
  1063.              Fuzzy => 0);
  1064.  
  1065.     ## Any and All are all code points.
  1066.     my $Any = Table->New(Is    => 'Any',
  1067.                          Desc  => sprintf("[\\x{0000}-\\x{%X}]",
  1068.                                           $LastUnicodeCodepoint),
  1069.                          Fuzzy => 0);
  1070.     $Any->RawAppendRange(0, $LastUnicodeCodepoint);
  1071.  
  1072.     New_Alias(Is => 'All', SameAs => 'Any', Fuzzy => 0);
  1073.  
  1074.     ##
  1075.     ## Build special properties for Perl's internal case-folding needs:
  1076.     ##    \p{_CaseIgnorable}
  1077.     ##    \p{_CanonDCIJ}
  1078.     ##    \p{_CombAbove}
  1079.     ## _CombAbove was built above. Others are built here....
  1080.     ##
  1081.  
  1082.     ## \p{_CaseIgnorable} is [\p{Mn}\0x00AD\x2010]
  1083.     New_Prop(Is => '_CaseIgnorable',
  1084.              Table->Merge($Cat{Mn},
  1085.                           0x00AD,    #SOFT HYPHEN
  1086.                           0x2010),   #HYPHEN
  1087.              Desc  => '(for internal casefolding use)',
  1088.              Fuzzy => 0);
  1089.  
  1090.  
  1091.     ## \p{_CanonDCIJ} is fairly complex...
  1092.     my $CanonCDIJ = Table->New(Is    => '_CanonDCIJ',
  1093.                                Desc  => '(for internal casefolding use)',
  1094.                                Fuzzy => 0);
  1095.     ## It contains the ASCII 'i' and 'j'....
  1096.     $CanonCDIJ->Append(0x0069); # ASCII ord("i")
  1097.     $CanonCDIJ->Append(0x006A); # ASCII ord("j")
  1098.     ## ...and any character with a decomposition that starts with either of
  1099.     ## those code points, but only if the decomposition does not have any
  1100.     ## combining character with the "ABOVE" canonical combining class.
  1101.     for my $code (sort { $a <=> $b} keys %CodeToDeco)
  1102.     {
  1103.         ## Need to ensure that all decomposition characters do not have
  1104.         ## a %HexCodeToComb in %AboveCombClasses.
  1105.         my $want = 1;
  1106.         for my $deco_hexcode (split / /, $CodeToDeco{$code})
  1107.         {
  1108.             if (exists $_Above_HexCodes{$deco_hexcode}) {
  1109.                 ## one of the decmposition chars has an ABOVE combination
  1110.                 ## class, so we're not interested in this one
  1111.                 $want = 0;
  1112.                 last;
  1113.             }
  1114.         }
  1115.         if ($want) {
  1116.             $CanonCDIJ->Append($code);
  1117.         }
  1118.     }
  1119.  
  1120.  
  1121.  
  1122.     ##
  1123.     ## Now dump the files.
  1124.     ##
  1125.     $Name->Write("Name.pl");
  1126.  
  1127.     {
  1128.     my @PVA = $HEADER;
  1129.     foreach my $name (qw (PropertyAlias PA_reverse PropValueAlias
  1130.                   PVA_reverse PVA_abbr_map)) {
  1131.         # Should I really jump through typeglob hoops just to avoid a
  1132.         # symbolic reference? (%{"utf8::$name})
  1133.         push @PVA, "\n", "\%utf8::$name = (\n",
  1134.         simple_dumper (%{$utf8::{$name}}), ");\n";
  1135.     }
  1136.     push @PVA, "1;\n";
  1137.     WriteIfChanged("PVA.pl", @PVA);
  1138.     }
  1139.  
  1140.     # $Bidi->Write("Bidirectional.pl");
  1141.     for (keys %Bidi) {
  1142.     $Bidi{$_}->Write(
  1143.         ["lib","bc","$_.pl"],
  1144.         "BidiClass category '$PropValueAlias{bc}{$_}'"
  1145.     );
  1146.     }
  1147.  
  1148.     $Comb->Write("CombiningClass.pl");
  1149.     for (keys %{ $PropValueAlias{ccc} }) {
  1150.     my ($code, $name) = @{ $PropValueAlias{ccc}{$_} };
  1151.     (my $c = Table->New())->Append($code);
  1152.     $c->Write(
  1153.         ["lib","ccc","$_.pl"],
  1154.         "CombiningClass category '$name'"
  1155.     );
  1156.     }
  1157.  
  1158.     $Deco->Write("Decomposition.pl");
  1159.     for (keys %DC) {
  1160.     $DC{$_}->Write(
  1161.         ["lib","dt","$_.pl"],
  1162.         "DecompositionType category '$PropValueAlias{dt}{$_}'"
  1163.     );
  1164.     }
  1165.  
  1166.     # $Number->Write("Number.pl");
  1167.     for (keys %Number) {
  1168.     $Number{$_}->Write(
  1169.         ["lib","nt","$_.pl"],
  1170.         "NumericType category '$PropValueAlias{nt}{$_}'"
  1171.     );
  1172.     }
  1173.  
  1174.     # $General->Write("Category.pl");
  1175.  
  1176.     for my $to (sort keys %To) {
  1177.         $To{$to}->Write(["To","$to.pl"]);
  1178.     }
  1179.  
  1180.     for (keys %{ $PropValueAlias{gc} }) {
  1181.     New_Alias(Is => $PropValueAlias{gc}{$_}, SameAs => $_, Fuzzy => 1);
  1182.     }
  1183. }
  1184.  
  1185. ##
  1186. ## Process LineBreak.txt
  1187. ##
  1188. sub LineBreak_Txt()
  1189. {
  1190.     if (not open IN, "LineBreak.txt") {
  1191.         die "$0: LineBreak.txt: $!\n";
  1192.     }
  1193.  
  1194.     my $Lbrk = Table->New();
  1195.     my %Lbrk;
  1196.  
  1197.     while (<IN>)
  1198.     {
  1199.         next unless /^([0-9A-Fa-f]+)(?:\.\.([0-9A-Fa-f]+))?\s*;\s*(\w+)/;
  1200.  
  1201.     my ($first, $last, $lbrk) = (hex($1), hex($2||""), $3);
  1202.  
  1203.     $Lbrk->Append($first, $lbrk);
  1204.  
  1205.         $Lbrk{$lbrk} ||= Table->New();
  1206.         $Lbrk{$lbrk}->Append($first);
  1207.  
  1208.     if ($last) {
  1209.         $Lbrk->Extend($last);
  1210.         $Lbrk{$lbrk}->Extend($last);
  1211.     }
  1212.     }
  1213.     close IN;
  1214.  
  1215.     # $Lbrk->Write("Lbrk.pl");
  1216.  
  1217.  
  1218.     for (keys %Lbrk) {
  1219.     $Lbrk{$_}->Write(
  1220.         ["lib","lb","$_.pl"],
  1221.         "Linebreak category '$PropValueAlias{lb}{$_}'"
  1222.     );
  1223.     }
  1224. }
  1225.  
  1226. ##
  1227. ## Process ArabicShaping.txt.
  1228. ##
  1229. sub ArabicShaping_txt()
  1230. {
  1231.     if (not open IN, "ArabicShaping.txt") {
  1232.         die "$0: ArabicShaping.txt: $!\n";
  1233.     }
  1234.  
  1235.     my $ArabLink      = Table->New();
  1236.     my $ArabLinkGroup = Table->New();
  1237.  
  1238.     my %JoinType;
  1239.  
  1240.     while (<IN>)
  1241.     {
  1242.     next unless /^[0-9A-Fa-f]+;/;
  1243.     s/\s+$//;
  1244.  
  1245.     my ($hexcode, $name, $link, $linkgroup) = split(/\s*;\s*/);
  1246.         my $code = hex($hexcode);
  1247.     $ArabLink->Append($code, $link);
  1248.     $ArabLinkGroup->Append($code, $linkgroup);
  1249.  
  1250.         $JoinType{$link} ||= Table->New(Is => "JoinType$link");
  1251.         $JoinType{$link}->Append($code);
  1252.     }
  1253.     close IN;
  1254.  
  1255.     # $ArabLink->Write("ArabLink.pl");
  1256.     # $ArabLinkGroup->Write("ArabLnkGrp.pl");
  1257.  
  1258.  
  1259.     for (keys %JoinType) {
  1260.     $JoinType{$_}->Write(
  1261.         ["lib","jt","$_.pl"],
  1262.         "JoiningType category '$PropValueAlias{jt}{$_}'"
  1263.     );
  1264.     }
  1265. }
  1266.  
  1267. ##
  1268. ## Process EastAsianWidth.txt.
  1269. ##
  1270. sub EastAsianWidth_txt()
  1271. {
  1272.     if (not open IN, "EastAsianWidth.txt") {
  1273.         die "$0: EastAsianWidth.txt: $!\n";
  1274.     }
  1275.  
  1276.     my %EAW;
  1277.  
  1278.     while (<IN>)
  1279.     {
  1280.     next unless /^[0-9A-Fa-f]+(\.\.[0-9A-Fa-f]+)?;/;
  1281.     s/#.*//;
  1282.     s/\s+$//;
  1283.  
  1284.     my ($hexcodes, $pv) = split(/\s*;\s*/);
  1285.         $EAW{$pv} ||= Table->New(Is => "EastAsianWidth$pv");
  1286.       my ($start, $end) = split(/\.\./, $hexcodes);
  1287.       if (defined $end) {
  1288.         $EAW{$pv}->AppendRange(hex($start), hex($end));
  1289.       } else {
  1290.         $EAW{$pv}->Append(hex($start));
  1291.       }
  1292.     }
  1293.     close IN;
  1294.  
  1295.  
  1296.     for (keys %EAW) {
  1297.     $EAW{$_}->Write(
  1298.         ["lib","ea","$_.pl"],
  1299.         "EastAsianWidth category '$PropValueAlias{ea}{$_}'"
  1300.     );
  1301.     }
  1302. }
  1303.  
  1304. ##
  1305. ## Process HangulSyllableType.txt.
  1306. ##
  1307. sub HangulSyllableType_txt()
  1308. {
  1309.     if (not open IN, "HangulSyllableType.txt") {
  1310.         die "$0: HangulSyllableType.txt: $!\n";
  1311.     }
  1312.  
  1313.     my %HST;
  1314.  
  1315.     while (<IN>)
  1316.     {
  1317.         next unless /^([0-9A-Fa-f]+)(?:\.\.([0-9A-Fa-f]+))?\s*;\s*(\w+)/;
  1318.     my ($first, $last, $pv) = (hex($1), hex($2||""), $3);
  1319.  
  1320.         $HST{$pv} ||= Table->New(Is => "HangulSyllableType$pv");
  1321.         $HST{$pv}->Append($first);
  1322.  
  1323.     if ($last) { $HST{$pv}->Extend($last) }
  1324.     }
  1325.     close IN;
  1326.  
  1327.     for (keys %HST) {
  1328.     $HST{$_}->Write(
  1329.         ["lib","hst","$_.pl"],
  1330.         "HangulSyllableType category '$PropValueAlias{hst}{$_}'"
  1331.     );
  1332.     }
  1333. }
  1334.  
  1335. ##
  1336. ## Process Jamo.txt.
  1337. ##
  1338. sub Jamo_txt()
  1339. {
  1340.     if (not open IN, "Jamo.txt") {
  1341.         die "$0: Jamo.txt: $!\n";
  1342.     }
  1343.     my $Short = Table->New();
  1344.  
  1345.     while (<IN>)
  1346.     {
  1347.     next unless /^([0-9A-Fa-f]+)\s*;\s*(\w*)/;
  1348.     my ($code, $short) = (hex($1), $2);
  1349.  
  1350.     $Short->Append($code, $short);
  1351.     }
  1352.     close IN;
  1353.     # $Short->Write("JamoShort.pl");
  1354. }
  1355.  
  1356. ##
  1357. ## Process Scripts.txt.
  1358. ##
  1359. sub Scripts_txt()
  1360. {
  1361.     my @ScriptInfo;
  1362.  
  1363.     if (not open(IN, "Scripts.txt")) {
  1364.         die "$0: Scripts.txt: $!\n";
  1365.     }
  1366.     while (<IN>) {
  1367.         next unless /^([0-9A-Fa-f]+)(?:\.\.([0-9A-Fa-f]+))?\s*;\s*(.+?)\s*\#/;
  1368.  
  1369.         # Wait until all the scripts have been read since
  1370.         # they are not listed in numeric order.
  1371.         push @ScriptInfo, [ hex($1), hex($2||""), $3 ];
  1372.     }
  1373.     close IN;
  1374.  
  1375.     # Now append the scripts properties in their code point order.
  1376.  
  1377.     my %Script;
  1378.     my $Scripts = Table->New();
  1379.  
  1380.     for my $script (sort { $a->[0] <=> $b->[0] } @ScriptInfo)
  1381.     {
  1382.         my ($first, $last, $name) = @$script;
  1383.         $Scripts->Append($first, $name);
  1384.  
  1385.         $Script{$name} ||= Table->New(Is    => $name,
  1386.                                       Desc  => "Script '$name'",
  1387.                                       Fuzzy => 1);
  1388.         $Script{$name}->Append($first, $name);
  1389.  
  1390.         if ($last) {
  1391.             $Scripts->Extend($last);
  1392.             $Script{$name}->Extend($last);
  1393.         }
  1394.     }
  1395.  
  1396.     # $Scripts->Write("Scripts.pl");
  1397.  
  1398.     ## Common is everything not explicitly assigned to a Script
  1399.     ##
  1400.     ##    ***shouldn't this be intersected with \p{Assigned}? ******
  1401.     ##
  1402.     New_Prop(Is => 'Common',
  1403.              $Scripts->Invert,
  1404.              Desc  => 'Pseudo-Script of codepoints not in other Unicode scripts',
  1405.              Fuzzy => 1);
  1406. }
  1407.  
  1408. ##
  1409. ## Given a name like "Close Punctuation", return a regex (that when applied
  1410. ## with /i) matches any valid form of that name (e.g. "ClosePunctuation",
  1411. ## "Close-Punctuation", etc.)
  1412. ##
  1413. ## Accept any space, dash, or underbar where in the official name there is
  1414. ## space or a dash (or underbar, but there never is).
  1415. ##
  1416. ##
  1417. sub NameToRegex($)
  1418. {
  1419.     my $Name = shift;
  1420.     $Name =~ s/[- _]/(?:[-_]|\\s+)?/g;
  1421.     return $Name;
  1422. }
  1423.  
  1424. ##
  1425. ## Process Blocks.txt.
  1426. ##
  1427. sub Blocks_txt()
  1428. {
  1429.     my $Blocks = Table->New();
  1430.     my %Blocks;
  1431.  
  1432.     if (not open IN, "Blocks.txt") {
  1433.         die "$0: Blocks.txt: $!\n";
  1434.     }
  1435.  
  1436.     while (<IN>)
  1437.     {
  1438.         #next if not /Private Use$/;
  1439.     next if not /^([0-9A-Fa-f]+)\.\.([0-9A-Fa-f]+)\s*;\s*(.+?)\s*$/;
  1440.  
  1441.     my ($first, $last, $name) = (hex($1), hex($2), $3);
  1442.  
  1443.     $Blocks->Append($first, $name);
  1444.  
  1445.         $Blocks{$name} ||= Table->New(In    => $name,
  1446.                                       Desc  => "Block '$name'",
  1447.                                       Fuzzy => 1);
  1448.         $Blocks{$name}->Append($first, $name);
  1449.  
  1450.     if ($last and $last != $first) {
  1451.         $Blocks->Extend($last);
  1452.         $Blocks{$name}->Extend($last);
  1453.     }
  1454.     }
  1455.     close IN;
  1456.  
  1457.     # $Blocks->Write("Blocks.pl");
  1458. }
  1459.  
  1460. ##
  1461. ## Read in the PropList.txt.  It contains extended properties not
  1462. ## listed in the UnicodeData.txt, such as 'Other_Alphabetic':
  1463. ## alphabetic but not of the general category L; many modifiers
  1464. ## belong to this extended property category: while they are not
  1465. ## alphabets, they are alphabetic in nature.
  1466. ##
  1467. sub PropList_txt()
  1468. {
  1469.     my @PropInfo;
  1470.  
  1471.     if (not open IN, "PropList.txt") {
  1472.         die "$0: PropList.txt: $!\n";
  1473.     }
  1474.  
  1475.     while (<IN>)
  1476.     {
  1477.     next unless /^([0-9A-Fa-f]+)(?:\.\.([0-9A-Fa-f]+))?\s*;\s*(.+?)\s*\#/;
  1478.  
  1479.     # Wait until all the extended properties have been read since
  1480.     # they are not listed in numeric order.
  1481.     push @PropInfo, [ hex($1), hex($2||""), $3 ];
  1482.     }
  1483.     close IN;
  1484.  
  1485.     # Now append the extended properties in their code point order.
  1486.     my $Props = Table->New();
  1487.     my %Prop;
  1488.  
  1489.     for my $prop (sort { $a->[0] <=> $b->[0] } @PropInfo)
  1490.     {
  1491.         my ($first, $last, $name) = @$prop;
  1492.         $Props->Append($first, $name);
  1493.  
  1494.         $Prop{$name} ||= Table->New(Is    => $name,
  1495.                                     Desc  => "Extended property '$name'",
  1496.                                     Fuzzy => 1);
  1497.         $Prop{$name}->Append($first, $name);
  1498.  
  1499.         if ($last) {
  1500.             $Props->Extend($last);
  1501.             $Prop{$name}->Extend($last);
  1502.         }
  1503.     }
  1504.  
  1505.     for (keys %Prop) {
  1506.     (my $file = $PA_reverse{$_}) =~ tr/_//d;
  1507.     # XXX I'm assuming that the names from %Prop don't suffer 8.3 clashes.
  1508.     $BaseNames{lc $file}++;
  1509.     $Prop{$_}->Write(
  1510.         ["lib","gc_sc","$file.pl"],
  1511.         "Binary property '$_'"
  1512.     );
  1513.     }
  1514.  
  1515.     # Alphabetic is L, Nl, and Other_Alphabetic.
  1516.     New_Prop(Is    => 'Alphabetic',
  1517.              Table->Merge($Cat{L}, $Cat{Nl}, $Prop{Other_Alphabetic}),
  1518.              Desc  => '[\p{L}\p{Nl}\p{OtherAlphabetic}]', # canonical names
  1519.              Fuzzy => 1);
  1520.  
  1521.     # Lowercase is Ll and Other_Lowercase.
  1522.     New_Prop(Is    => 'Lowercase',
  1523.              Table->Merge($Cat{Ll}, $Prop{Other_Lowercase}),
  1524.              Desc  => '[\p{Ll}\p{OtherLowercase}]', # canonical names
  1525.              Fuzzy => 1);
  1526.  
  1527.     # Uppercase is Lu and Other_Uppercase.
  1528.     New_Prop(Is => 'Uppercase',
  1529.              Table->Merge($Cat{Lu}, $Prop{Other_Uppercase}),
  1530.              Desc  => '[\p{Lu}\p{OtherUppercase}]', # canonical names
  1531.              Fuzzy => 1);
  1532.  
  1533.     # Math is Sm and Other_Math.
  1534.     New_Prop(Is => 'Math',
  1535.              Table->Merge($Cat{Sm}, $Prop{Other_Math}),
  1536.              Desc  => '[\p{Sm}\p{OtherMath}]', # canonical names
  1537.              Fuzzy => 1);
  1538.  
  1539.     # ID_Start is Ll, Lu, Lt, Lm, Lo, Nl, and Other_ID_Start.
  1540.     New_Prop(Is => 'ID_Start',
  1541.              Table->Merge(@Cat{qw[Ll Lu Lt Lm Lo Nl]}, $Prop{Other_ID_Start}),
  1542.              Desc  => '[\p{Ll}\p{Lu}\p{Lt}\p{Lm}\p{Lo}\p{Nl}\p{OtherIDStart}]',
  1543.              Fuzzy => 1);
  1544.  
  1545.     # ID_Continue is ID_Start, Mn, Mc, Nd, Pc, and Other_ID_Continue.
  1546.     New_Prop(Is => 'ID_Continue',
  1547.              Table->Merge(@Cat{qw[Ll Lu Lt Lm Lo Nl Mn Mc Nd Pc ]},
  1548.                           @Prop{qw[Other_ID_Start Other_ID_Continue]}),
  1549.              Desc  => '[\p{ID_Start}\p{Mn}\p{Mc}\p{Nd}\p{Pc}\p{OtherIDContinue}]',
  1550.              Fuzzy => 1);
  1551.  
  1552.     # Default_Ignorable_Code_Point = Other_Default_Ignorable_Code_Point
  1553.     #                     + Cf + Cc + Cs + Noncharacter + Variation_Selector
  1554.     #                     - WhiteSpace - FFF9..FFFB (Annotation Characters)
  1555.  
  1556.     my $Annotation = Table->New();
  1557.     $Annotation->RawAppendRange(0xFFF9, 0xFFFB);
  1558.  
  1559.     New_Prop(Is => 'Default_Ignorable_Code_Point',
  1560.              Table->Merge(@Cat{qw[Cf Cc Cs]},
  1561.                           $Prop{Noncharacter_Code_Point},
  1562.                           $Prop{Variation_Selector},
  1563.                           $Prop{Other_Default_Ignorable_Code_Point})
  1564.                   ->Invert
  1565.                   ->Merge($Prop{White_Space}, $Annotation)
  1566.                   ->Invert,
  1567.              Desc  => '(?![\p{WhiteSpace}\x{FFF9}-\x{FFFB}])[\p{Cf}\p{Cc}'.
  1568.                       '\p{Cs}\p{NoncharacterCodePoint}\p{VariationSelector}'.
  1569.                       '\p{OtherDefaultIgnorableCodePoint}]',
  1570.              Fuzzy => 1);
  1571.  
  1572. }
  1573.  
  1574.  
  1575. ##
  1576. ## These are used in:
  1577. ##   MakePropTestScript()
  1578. ##   WriteAllMappings()
  1579. ## for making the test script.
  1580. ##
  1581. my %FuzzyNameToTest;
  1582. my %ExactNameToTest;
  1583.  
  1584.  
  1585. ## This used only for making the test script
  1586. sub GenTests($$$$)
  1587. {
  1588.     my $FH = shift;
  1589.     my $Prop = shift;
  1590.     my $MatchCode = shift;
  1591.     my $FailCode = shift;
  1592.  
  1593.     if (defined $MatchCode) {
  1594.         printf $FH qq/Expect(1, "\\x{%04X}", '\\p{$Prop}' );\n/, $MatchCode;
  1595.         printf $FH qq/Expect(0, "\\x{%04X}", '\\p{^$Prop}');\n/, $MatchCode;
  1596.         printf $FH qq/Expect(0, "\\x{%04X}", '\\P{$Prop}' );\n/, $MatchCode;
  1597.         printf $FH qq/Expect(1, "\\x{%04X}", '\\P{^$Prop}');\n/, $MatchCode;
  1598.     }
  1599.     if (defined $FailCode) {
  1600.         printf $FH qq/Expect(0, "\\x{%04X}", '\\p{$Prop}' );\n/, $FailCode;
  1601.         printf $FH qq/Expect(1, "\\x{%04X}", '\\p{^$Prop}');\n/, $FailCode;
  1602.         printf $FH qq/Expect(1, "\\x{%04X}", '\\P{$Prop}' );\n/, $FailCode;
  1603.         printf $FH qq/Expect(0, "\\x{%04X}", '\\P{^$Prop}');\n/, $FailCode;
  1604.     }
  1605. }
  1606.  
  1607. ## This used only for making the test script
  1608. sub ExpectError($$)
  1609. {
  1610.     my $FH = shift;
  1611.     my $prop = shift;
  1612.  
  1613.     print $FH qq/Error('\\p{$prop}');\n/;
  1614.     print $FH qq/Error('\\P{$prop}');\n/;
  1615. }
  1616.  
  1617. ## This used only for making the test script
  1618. my @GoodSeps = (
  1619.                 " ",
  1620.                 "-",
  1621.                 " \t ",
  1622.                 "",
  1623.                 "",
  1624.                 "_",
  1625.                );
  1626. my @BadSeps = (
  1627.                "--",
  1628.                "__",
  1629.                " _",
  1630.                "/"
  1631.               );
  1632.  
  1633. ## This used only for making the test script
  1634. sub RandomlyFuzzifyName($;$)
  1635. {
  1636.     my $Name = shift;
  1637.     my $WantError = shift;  ## if true, make an error
  1638.  
  1639.     my @parts;
  1640.     for my $part (split /[-\s_]+/, $Name)
  1641.     {
  1642.         if (@parts) {
  1643.             if ($WantError and rand() < 0.3) {
  1644.                 push @parts, $BadSeps[rand(@BadSeps)];
  1645.                 $WantError = 0;
  1646.             } else {
  1647.                 push @parts, $GoodSeps[rand(@GoodSeps)];
  1648.             }
  1649.         }
  1650.         my $switch = int rand(4);
  1651.         if ($switch == 0) {
  1652.             push @parts, uc $part;
  1653.         } elsif ($switch == 1) {
  1654.             push @parts, lc $part;
  1655.         } elsif ($switch == 2) {
  1656.             push @parts, ucfirst $part;
  1657.         } else {
  1658.             push @parts, $part;
  1659.         }
  1660.     }
  1661.     my $new = join('', @parts);
  1662.  
  1663.     if ($WantError) {
  1664.         if (rand() >= 0.5) {
  1665.             $new .= $BadSeps[rand(@BadSeps)];
  1666.         } else {
  1667.             $new = $BadSeps[rand(@BadSeps)] . $new;
  1668.         }
  1669.     }
  1670.     return $new;
  1671. }
  1672.  
  1673. ## This used only for making the test script
  1674. sub MakePropTestScript()
  1675. {
  1676.     ## this written directly -- it's huge.
  1677.     force_unlink ("TestProp.pl");
  1678.     if (not open OUT, ">TestProp.pl") {
  1679.         die "$0: TestProp.pl: $!\n";
  1680.     }
  1681.     print OUT <DATA>;
  1682.  
  1683.     while (my ($Name, $Table) = each %ExactNameToTest)
  1684.     {
  1685.         GenTests(*OUT, $Name, $Table->ValidCode, $Table->InvalidCode);
  1686.         ExpectError(*OUT, uc $Name) if uc $Name ne $Name;
  1687.         ExpectError(*OUT, lc $Name) if lc $Name ne $Name;
  1688.     }
  1689.  
  1690.  
  1691.     while (my ($Name, $Table) = each %FuzzyNameToTest)
  1692.     {
  1693.         my $Orig  = $CanonicalToOrig{$Name};
  1694.         my %Names = (
  1695.                      $Name => 1,
  1696.                      $Orig => 1,
  1697.                      RandomlyFuzzifyName($Orig) => 1
  1698.                     );
  1699.  
  1700.         for my $N (keys %Names) {
  1701.             GenTests(*OUT, $N, $Table->ValidCode, $Table->InvalidCode);
  1702.         }
  1703.  
  1704.         ExpectError(*OUT, RandomlyFuzzifyName($Orig, 'ERROR'));
  1705.     }
  1706.  
  1707.     print OUT "Finished();\n";
  1708.     close OUT;
  1709. }
  1710.  
  1711.  
  1712. ##
  1713. ## These are used only in:
  1714. ##   RegisterFileForName()
  1715. ##   WriteAllMappings()
  1716. ##
  1717. my %Exact;      ## will become %utf8::Exact;
  1718. my %Canonical;  ## will become %utf8::Canonical;
  1719. my %CaComment;  ## Comment for %Canonical entry of same key
  1720.  
  1721. ##
  1722. ## Given info about a name and a datafile that it should be associated with,
  1723. ## register that assocation in %Exact and %Canonical.
  1724. sub RegisterFileForName($$$$)
  1725. {
  1726.     my $Type     = shift;
  1727.     my $Name     = shift;
  1728.     my $IsFuzzy  = shift;
  1729.     my $filename = shift;
  1730.  
  1731.     ##
  1732.     ## Now in details for the mapping. $Type eq 'Is' has the
  1733.     ## Is removed, as it will be removed in utf8_heavy when this
  1734.     ## data is being checked. In keeps its "In", but a second
  1735.     ## sans-In record is written if it doesn't conflict with
  1736.     ## anything already there.
  1737.     ##
  1738.     if (not $IsFuzzy)
  1739.     {
  1740.         if ($Type eq 'Is') {
  1741.             die "oops[$Name]" if $Exact{$Name};
  1742.             $Exact{$Name} = $filename;
  1743.         } else {
  1744.             die "oops[$Type$Name]" if $Exact{"$Type$Name"};
  1745.             $Exact{"$Type$Name"} = $filename;
  1746.             $Exact{$Name} = $filename if not $Exact{$Name};
  1747.         }
  1748.     }
  1749.     else
  1750.     {
  1751.         my $CName = lc $Name;
  1752.         if ($Type eq 'Is') {
  1753.             die "oops[$CName]" if $Canonical{$CName};
  1754.             $Canonical{$CName} = $filename;
  1755.             $CaComment{$CName} = $Name if $Name =~ tr/A-Z// >= 2;
  1756.         } else {
  1757.             die "oops[$Type$CName]" if $Canonical{lc "$Type$CName"};
  1758.             $Canonical{lc "$Type$CName"} = $filename;
  1759.             $CaComment{lc "$Type$CName"} = "$Type$Name";
  1760.             if (not $Canonical{$CName}) {
  1761.                 $Canonical{$CName} = $filename;
  1762.                 $CaComment{$CName} = "$Type$Name";
  1763.             }
  1764.         }
  1765.     }
  1766. }
  1767.  
  1768. ##
  1769. ## Writes the info accumulated in
  1770. ##
  1771. ##       %TableInfo;
  1772. ##       %FuzzyNames;
  1773. ##       %AliasInfo;
  1774. ##
  1775. ##
  1776. sub WriteAllMappings()
  1777. {
  1778.     my @MAP;
  1779.  
  1780.     ## 'Is' *MUST* come first, so its names have precidence over 'In's
  1781.     for my $Type ('Is', 'In')
  1782.     {
  1783.         my %RawNameToFile; ## a per-$Type cache
  1784.  
  1785.         for my $Name (sort {length $a <=> length $b} keys %{$TableInfo{$Type}})
  1786.         {
  1787.             ## Note: $Name is already canonical
  1788.             my $Table   = $TableInfo{$Type}->{$Name};
  1789.             my $IsFuzzy = $FuzzyNames{$Type}->{$Name};
  1790.  
  1791.             ## Need an 8.3 safe filename (which means "an 8 safe" $filename)
  1792.             my $filename;
  1793.             {
  1794.                 ## 'Is' items lose 'Is' from the basename.
  1795.                 $filename = $Type eq 'Is' ?
  1796.             ($PVA_reverse{sc}{$Name} || $Name) :
  1797.             "$Type$Name";
  1798.  
  1799.                 $filename =~ s/[^\w_]+/_/g; # "L&" -> "L_"
  1800.                 substr($filename, 8) = '' if length($filename) > 8;
  1801.  
  1802.                 ##
  1803.                 ## Make sure the basename doesn't conflict with something we
  1804.                 ## might have already written. If we have, say,
  1805.                 ##     InGreekExtended1
  1806.                 ##     InGreekExtended2
  1807.                 ## they become
  1808.                 ##     InGreekE
  1809.                 ##     InGreek2
  1810.                 ##
  1811.                 while (my $num = $BaseNames{lc $filename}++)
  1812.                 {
  1813.                     $num++; ## so basenames with numbers start with '2', which
  1814.                             ## just looks more natural.
  1815.                     ## Want to append $num, but if it'll make the basename longer
  1816.                     ## than 8 characters, pre-truncate $filename so that the result
  1817.                     ## is acceptable.
  1818.                     my $delta = length($filename) + length($num) - 8;
  1819.                     if ($delta > 0) {
  1820.                         substr($filename, -$delta) = $num;
  1821.                     } else {
  1822.                         $filename .= $num;
  1823.                     }
  1824.                 }
  1825.             };
  1826.  
  1827.             ##
  1828.             ## Construct a nice comment to add to the file, and build data
  1829.             ## for the "./Properties" file along the way.
  1830.             ##
  1831.             my $Comment;
  1832.             {
  1833.                 my $Desc = $TableDesc{$Type}->{$Name} || "";
  1834.                 ## get list of names this table is reference by
  1835.                 my @Supported = $Name;
  1836.                 while (my ($Orig, $Alias) = each %{ $AliasInfo{$Type} })
  1837.                 {
  1838.                     if ($Orig eq $Name) {
  1839.                         push @Supported, $Alias;
  1840.                     }
  1841.                 }
  1842.  
  1843.                 my $TypeToShow = $Type eq 'Is' ? "" : $Type;
  1844.                 my $OrigProp;
  1845.  
  1846.                 $Comment = "This file supports:\n";
  1847.                 for my $N (@Supported)
  1848.                 {
  1849.                     my $IsFuzzy = $FuzzyNames{$Type}->{$N};
  1850.                     my $Prop    = "\\p{$TypeToShow$Name}";
  1851.                     $OrigProp = $Prop if not $OrigProp; #cache for aliases
  1852.                     if ($IsFuzzy) {
  1853.                         $Comment .= "\t$Prop (and fuzzy permutations)\n";
  1854.                     } else {
  1855.                         $Comment .= "\t$Prop\n";
  1856.                     }
  1857.                     my $MyDesc = ($N eq $Name) ? $Desc : "Alias for $OrigProp ($Desc)";
  1858.  
  1859.                     push @MAP, sprintf("%s %-42s %s\n",
  1860.                                        $IsFuzzy ? '*' : ' ', $Prop, $MyDesc);
  1861.                 }
  1862.                 if ($Desc) {
  1863.                     $Comment .= "\nMeaning: $Desc\n";
  1864.                 }
  1865.  
  1866.             }
  1867.             ##
  1868.             ## Okay, write the file...
  1869.             ##
  1870.             $Table->Write(["lib","gc_sc","$filename.pl"], $Comment);
  1871.  
  1872.             ## and register it
  1873.             $RawNameToFile{$Name} = $filename;
  1874.             RegisterFileForName($Type => $Name, $IsFuzzy, $filename);
  1875.  
  1876.             if ($IsFuzzy)
  1877.             {
  1878.                 my $CName = CanonicalName($Type . '_'. $Name);
  1879.                 $FuzzyNameToTest{$Name}  = $Table if !$FuzzyNameToTest{$Name};
  1880.                 $FuzzyNameToTest{$CName} = $Table if !$FuzzyNameToTest{$CName};
  1881.             } else {
  1882.                 $ExactNameToTest{$Name} = $Table;
  1883.             }
  1884.  
  1885.         }
  1886.  
  1887.         ## Register aliase info
  1888.         for my $Name (sort {length $a <=> length $b} keys %{$AliasInfo{$Type}})
  1889.         {
  1890.             my $Alias    = $AliasInfo{$Type}->{$Name};
  1891.             my $IsFuzzy  = $FuzzyNames{$Type}->{$Alias};
  1892.             my $filename = $RawNameToFile{$Name};
  1893.             die "oops [$Alias]->[$Name]" if not $filename;
  1894.             RegisterFileForName($Type => $Alias, $IsFuzzy, $filename);
  1895.  
  1896.             my $Table = $TableInfo{$Type}->{$Name};
  1897.             die "oops" if not $Table;
  1898.             if ($IsFuzzy)
  1899.             {
  1900.                 my $CName = CanonicalName($Type .'_'. $Alias);
  1901.                 $FuzzyNameToTest{$Alias} = $Table if !$FuzzyNameToTest{$Alias};
  1902.                 $FuzzyNameToTest{$CName} = $Table if !$FuzzyNameToTest{$CName};
  1903.             } else {
  1904.                 $ExactNameToTest{$Alias} = $Table;
  1905.             }
  1906.         }
  1907.     }
  1908.  
  1909.     ##
  1910.     ## Write out the property list
  1911.     ##
  1912.     {
  1913.         my @OUT = (
  1914.                    "##\n",
  1915.                    "## This file created by $0\n",
  1916.                    "## List of built-in \\p{...}/\\P{...} properties.\n",
  1917.                    "##\n",
  1918.                    "## '*' means name may be 'fuzzy'\n",
  1919.                    "##\n\n",
  1920.                    sort { substr($a,2) cmp substr($b, 2) } @MAP,
  1921.                   );
  1922.         WriteIfChanged('Properties', @OUT);
  1923.     }
  1924.  
  1925.     use Text::Tabs ();  ## using this makes the files about half the size
  1926.  
  1927.     ## Write Exact.pl
  1928.     {
  1929.         my @OUT = (
  1930.                    $HEADER,
  1931.                    "##\n",
  1932.                    "## Data in this file used by ../utf8_heavy.pl\n",
  1933.                    "##\n\n",
  1934.                    "## Mapping from name to filename in ./lib/gc_sc\n",
  1935.                    "%utf8::Exact = (\n",
  1936.                   );
  1937.  
  1938.     $Exact{InGreek} = 'InGreekA';  # this is evil kludge
  1939.         for my $Name (sort keys %Exact)
  1940.         {
  1941.             my $File = $Exact{$Name};
  1942.             $Name = $Name =~ m/\W/ ? qq/'$Name'/ : " $Name ";
  1943.             my $Text = sprintf("%-15s => %s,\n", $Name, qq/'$File'/);
  1944.             push @OUT, Text::Tabs::unexpand($Text);
  1945.         }
  1946.         push @OUT, ");\n1;\n";
  1947.  
  1948.         WriteIfChanged('Exact.pl', @OUT);
  1949.     }
  1950.  
  1951.     ## Write Canonical.pl
  1952.     {
  1953.         my @OUT = (
  1954.                    $HEADER,
  1955.                    "##\n",
  1956.                    "## Data in this file used by ../utf8_heavy.pl\n",
  1957.                    "##\n\n",
  1958.                    "## Mapping from lc(canonical name) to filename in ./lib\n",
  1959.                    "%utf8::Canonical = (\n",
  1960.                   );
  1961.         my $Trail = ""; ## used just to keep the spacing pretty
  1962.         for my $Name (sort keys %Canonical)
  1963.         {
  1964.             my $File = $Canonical{$Name};
  1965.             if ($CaComment{$Name}) {
  1966.                 push @OUT, "\n" if not $Trail;
  1967.                 push @OUT, " # $CaComment{$Name}\n";
  1968.                 $Trail = "\n";
  1969.             } else {
  1970.                 $Trail = "";
  1971.             }
  1972.             $Name = $Name =~ m/\W/ ? qq/'$Name'/ : " $Name ";
  1973.             my $Text = sprintf("  %-41s => %s,\n$Trail", $Name, qq/'$File'/);
  1974.             push @OUT, Text::Tabs::unexpand($Text);
  1975.         }
  1976.         push @OUT, ");\n1\n";
  1977.         WriteIfChanged('Canonical.pl', @OUT);
  1978.     }
  1979.  
  1980.     MakePropTestScript() if $MakeTestScript;
  1981. }
  1982.  
  1983.  
  1984. sub SpecialCasing_txt()
  1985. {
  1986.     #
  1987.     # Read in the special cases.
  1988.     #
  1989.  
  1990.     my %CaseInfo;
  1991.  
  1992.     if (not open IN, "SpecialCasing.txt") {
  1993.         die "$0: SpecialCasing.txt: $!\n";
  1994.     }
  1995.     while (<IN>) {
  1996.         next unless /^[0-9A-Fa-f]+;/;
  1997.         s/\#.*//;
  1998.         s/\s+$//;
  1999.  
  2000.         my ($code, $lower, $title, $upper, $condition) = split(/\s*;\s*/);
  2001.  
  2002.         if ($condition) { # not implemented yet
  2003.             print "# SKIPPING $_\n" if $Verbose;
  2004.             next;
  2005.         }
  2006.  
  2007.         # Wait until all the special cases have been read since
  2008.         # they are not listed in numeric order.
  2009.         my $ix = hex($code);
  2010.         push @{$CaseInfo{Lower}}, [ $ix, $code, $lower ]
  2011.         unless $code eq $lower;
  2012.         push @{$CaseInfo{Title}}, [ $ix, $code, $title ]
  2013.         unless $code eq $title;
  2014.         push @{$CaseInfo{Upper}}, [ $ix, $code, $upper ]
  2015.         unless $code eq $upper;
  2016.     }
  2017.     close IN;
  2018.  
  2019.     # Now write out the special cases properties in their code point order.
  2020.     # Prepend them to the To/{Upper,Lower,Title}.pl.
  2021.  
  2022.     for my $case (qw(Lower Title Upper))
  2023.     {
  2024.         my $NormalCase = do "To/$case.pl" || die "$0: $@\n";
  2025.  
  2026.         my @OUT =
  2027.         (
  2028.          $HEADER, "\n",
  2029.          "# The key UTF-8 _bytes_, the value UTF-8 (speed hack)\n",
  2030.          "%utf8::ToSpec$case =\n(\n",
  2031.         );
  2032.  
  2033.         for my $prop (sort { $a->[0] <=> $b->[0] } @{$CaseInfo{$case}}) {
  2034.             my ($ix, $code, $to) = @$prop;
  2035.             my $tostr =
  2036.               join "", map { sprintf "\\x{%s}", $_ } split ' ', $to;
  2037.             push @OUT, sprintf qq["%s" => "$tostr",\n], join("", map { sprintf "\\x%02X", $_ } unpack("U0C*", pack("U", $ix)));
  2038.         # Remove any single-character mappings for
  2039.         # the same character since we are going for
  2040.         # the special casing rules.
  2041.         $NormalCase =~ s/^$code\t\t\w+\n//m;
  2042.         }
  2043.         push @OUT, (
  2044.                     ");\n\n",
  2045.                     "return <<'END';\n",
  2046.                     $NormalCase,
  2047.                     "END\n"
  2048.                     );
  2049.         WriteIfChanged(["To","$case.pl"], @OUT);
  2050.     }
  2051. }
  2052.  
  2053. #
  2054. # Read in the case foldings.
  2055. #
  2056. # We will do full case folding, C + F + I (see CaseFolding.txt).
  2057. #
  2058. sub CaseFolding_txt()
  2059. {
  2060.     if (not open IN, "CaseFolding.txt") {
  2061.     die "$0: CaseFolding.txt: $!\n";
  2062.     }
  2063.  
  2064.     my $Fold = Table->New();
  2065.     my %Fold;
  2066.  
  2067.     while (<IN>) {
  2068.     # Skip status 'S', simple case folding
  2069.     next unless /^([0-9A-Fa-f]+)\s*;\s*([CFI])\s*;\s*([0-9A-Fa-f]+(?: [0-9A-Fa-f]+)*)\s*;/;
  2070.  
  2071.     my ($code, $status, $fold) = (hex($1), $2, $3);
  2072.  
  2073.     if ($status eq 'C') { # Common: one-to-one folding
  2074.         # No append() since several codes may fold into one.
  2075.         $Fold->RawAppendRange($code, $code, $fold);
  2076.     } else { # F: full, or I: dotted uppercase I -> dotless lowercase I
  2077.         $Fold{$code} = $fold;
  2078.     }
  2079.     }
  2080.     close IN;
  2081.  
  2082.     $Fold->Write("To/Fold.pl");
  2083.  
  2084.     #
  2085.     # Prepend the special foldings to the common foldings.
  2086.     #
  2087.     my $CommonFold = do "To/Fold.pl" || die "$0: To/Fold.pl: $!\n";
  2088.  
  2089.     my @OUT =
  2090.     (
  2091.      $HEADER, "\n",
  2092.      "#  The ke UTF-8 _bytes_, the value UTF-8 (speed hack)\n",
  2093.      "%utf8::ToSpecFold =\n(\n",
  2094.     );
  2095.     for my $code (sort { $a <=> $b } keys %Fold) {
  2096.         my $foldstr =
  2097.           join "", map { sprintf "\\x{%s}", $_ } split ' ', $Fold{$code};
  2098.         push @OUT, sprintf qq["%s" => "$foldstr",\n], join("", map { sprintf "\\x%02X", $_ } unpack("U0C*", pack("U", $code)));
  2099.     }
  2100.     push @OUT, (
  2101.                 ");\n\n",
  2102.                 "return <<'END';\n",
  2103.                 $CommonFold,
  2104.                 "END\n",
  2105.                );
  2106.  
  2107.     WriteIfChanged(["To","Fold.pl"], @OUT);
  2108. }
  2109.  
  2110. ## Do it....
  2111.  
  2112. Build_Aliases();
  2113. UnicodeData_Txt();
  2114. PropList_txt();
  2115.  
  2116. Scripts_txt();
  2117. Blocks_txt();
  2118.  
  2119. WriteAllMappings();
  2120.  
  2121. LineBreak_Txt();
  2122. ArabicShaping_txt();
  2123. EastAsianWidth_txt();
  2124. HangulSyllableType_txt();
  2125. Jamo_txt();
  2126. SpecialCasing_txt();
  2127. CaseFolding_txt();
  2128.  
  2129. if ( $FileList and $MakeList ) {
  2130.     
  2131.     print "Updating '$FileList'\n"
  2132.         if ($Verbose);
  2133.         
  2134.     open my $ofh,">",$FileList 
  2135.         or die "Can't write to '$FileList':$!";
  2136.     print $ofh <<"EOFHEADER";
  2137. #
  2138. # mktables.lst -- File list for mktables.
  2139. #
  2140. #   Autogenerated on @{[scalar localtime]}
  2141. #
  2142. # - First section is input files
  2143. #   (mktables itself is automatically included)
  2144. # - Section seperator is /^=+\$/
  2145. # - Second section is a list of output files.
  2146. # - Lines matching /^\\s*#/ are treated as comments
  2147. #   which along with blank lines are ignored.
  2148. #
  2149.  
  2150. # Input files:
  2151.  
  2152. EOFHEADER
  2153.     my @input=("version",glob('*.txt'));
  2154.     print $ofh "$_\n" for 
  2155.         @input,
  2156.         "\n=================================\n",
  2157.         "# Output files:\n",
  2158.         # special files
  2159.         "Properties";
  2160.         
  2161.     
  2162.     require File::Find;
  2163.     my $count=0;
  2164.     File::Find::find({
  2165.         no_chdir=>1,
  2166.         wanted=>sub {
  2167.           if (/\.pl$/) {
  2168.             s!^\./!!;
  2169.             print $ofh "$_\n";
  2170.             $count++;
  2171.           }
  2172.         },
  2173.     },"."); 
  2174.     
  2175.     print $ofh "\n# ",scalar(@input)," input files\n",
  2176.                "# ",scalar($count+1)," output files\n\n",
  2177.                "# End list\n";  
  2178.     close $ofh 
  2179.         or warn "Failed to close $ofh: $!";
  2180.     
  2181.     print "Filelist has ",scalar(@input)," input files and ",
  2182.           scalar($count+1)," output files\n"
  2183.         if $Verbose;
  2184. }
  2185. print "All done\n" if $Verbose;
  2186. exit(0);
  2187.  
  2188. ## TRAILING CODE IS USED BY MakePropTestScript()
  2189. __DATA__
  2190. use strict;
  2191. use warnings;
  2192.  
  2193. my $Tests = 0;
  2194. my $Fails = 0;
  2195.  
  2196. sub Expect($$$)
  2197. {
  2198.     my $Expect = shift;
  2199.     my $String = shift;
  2200.     my $Regex  = shift;
  2201.     my $Line   = (caller)[2];
  2202.  
  2203.     $Tests++;
  2204.     my $RegObj;
  2205.     my $result = eval {
  2206.         $RegObj = qr/$Regex/;
  2207.         $String =~ $RegObj ? 1 : 0
  2208.     };
  2209.     
  2210.     if (not defined $result) {
  2211.         print "couldn't compile /$Regex/ on $0 line $Line: $@\n";
  2212.         $Fails++;
  2213.     } elsif ($result ^ $Expect) {
  2214.         print "bad result (expected $Expect) on $0 line $Line: $@\n";
  2215.         $Fails++;
  2216.     }
  2217. }
  2218.  
  2219. sub Error($)
  2220. {
  2221.     my $Regex  = shift;
  2222.     $Tests++;
  2223.     if (eval { 'x' =~ qr/$Regex/; 1 }) {
  2224.         $Fails++;
  2225.         my $Line = (caller)[2];
  2226.         print "expected error for /$Regex/ on $0 line $Line: $@\n";
  2227.     }
  2228. }
  2229.  
  2230. sub Finished()
  2231. {
  2232.    if ($Fails == 0) {
  2233.       print "All $Tests tests passed.\n";
  2234.       exit(0);
  2235.    } else {
  2236.       print "$Tests tests, $Fails failed!\n";
  2237.       exit(-1);
  2238.    }
  2239. }
  2240.